home *** CD-ROM | disk | FTP | other *** search
VERSION 2.00 Begin Form Amida BorderStyle = 1 ' FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 5850 Icon = AMIDA.FRX:0000 Left = 1020 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 5445 ScaleWidth = 8340 Top = 4350 Width = 8460 Begin PictureBox SobFace Height = 400 Left = 0 Picture = AMIDA.FRX:0302 ScaleHeight = 375 ScaleWidth = 375 TabIndex = 29 TabStop = 0 'False Top = 1920 Visible = 0 'False Width = 400 End Begin PictureBox SmileFace Height = 400 Left = 0 Picture = AMIDA.FRX:057C ScaleHeight = 375 ScaleWidth = 375 TabIndex = 28 TabStop = 0 'False Top = 960 Visible = 0 'False Width = 400 End Begin PictureBox CalmFace Height = 400 Left = 0 Picture = AMIDA.FRX:07F6 ScaleHeight = 375 ScaleWidth = 375 TabIndex = 27 TabStop = 0 'False Top = 1440 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 19 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 0 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 18 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 7 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 17 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 8 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 16 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 9 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 15 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 10 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 14 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 11 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 13 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 12 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 12 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 13 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 11 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 14 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 10 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 15 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 9 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 16 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 8 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 17 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 7 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 18 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 6 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 19 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 5 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 20 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 4 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 21 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 3 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 22 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 2 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 23 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 1 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 24 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin PictureBox Lot BorderStyle = 0 ' Height = 400 Index = 0 Left = 0 ScaleHeight = 405 ScaleWidth = 405 TabIndex = 25 TabStop = 0 'False Top = 480 Visible = 0 'False Width = 400 End Begin CommandButton DrawCmd Caption = "&All at once" FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 492 Index = 1 Left = 3480 TabIndex = 2 Top = 0 Width = 2532 End Begin CommandButton HelpCmd Caption = "&Help" FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 492 Left = 6000 TabIndex = 3 Top = 0 Width = 1212 End Begin CommandButton ExitCmd Cancel = -1 'True Caption = "E&xit" FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 492 Left = 7200 TabIndex = 4 Top = 0 Width = 1212 End Begin CommandButton DrawCmd Caption = "&One at a time" FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 492 Index = 0 Left = 1200 TabIndex = 1 Top = 0 Width = 2292 End Begin CommandButton NewCmd Caption = "&New" Default = -1 'True FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 492 Left = 0 TabIndex = 26 Top = 0 Width = 1212 End Begin Label NumPrizesLbl FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 252 Left = 120 TabIndex = 6 Top = 4920 Width = 1692 End Begin Label PromptLbl Alignment = 2 ' FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 252 Left = 1920 TabIndex = 5 Top = 4920 Width = 5412 End Dim Shared BarExists() As Integer Dim Shared PolePos() As Integer Dim Shared BarPos() As Integer Dim Shared LotStatus() As Integer Dim Shared PrizeStatus() As Integer Dim Shared IsPrize() As Integer Dim Shared OwnerName$() Dim Shared PoleInterval As Integer Dim Shared BarInterval As Integer Dim Shared PuttingBar As Integer Dim Shared AddedBarPoleNo As Integer Dim Shared AddedBarStepNo As Integer Dim Shared NumDrawnPrizes As Integer Dim Shared AlreadyDrawnOnce As Integer Dim Shared JustDrawn As Integer Dim Shared CharacterBaseFace As Integer Sub DrawCmd_Click (Index As Integer) Dim LotNo As Integer If NumLots = 0 Or NumDrawnPrizes = NumPrizes Then Beep Exit Sub End If PuttingBar = False For LotNo = 1 To NumLots If LotStatus(LotNo) = SELECTED Then Call DrawLot(LotNo) If Index = 0 Or NumDrawnPrizes = NumPrizes Then Exit For End If Next Call Prompt End Sub Sub DrawLot (LotNo As Integer) Dim PrizePos As Integer If JustDrawn Then Refresh JustDrawn = True 'This flag indicates a need of redraw lines that was traced when casting a lot AlreadyDrawnOnce = True 'This flag prohibits adding more bars PrizePos = TraceAmida(LotNo) PrizeStatus(PrizePos) = VIEWED If IsPrize(PrizePos) Then LotStatus(LotNo) = PRIZE NumDrawnPrizes = NumDrawnPrizes + 1 Else LotStatus(LotNo) = BLANK End If Call PrintFace(LotNo, LotStatus(LotNo)) Call PrintPrize(PrizePos) If NumDrawnPrizes >= NumPrizes Then 'Now all prizes were drawn. So remaining lots are blank! For i% = LotNo + 1 To NumLots If LotStatus(i%) = SELECTED Then LotStatus(i%) = BLANK Call PrintFace(i%, LotStatus(i%)) End If Next For PrizePos = 1 To NumLots If PrizeStatus(PrizePos) = UNKNOWN Then PrizeStatus(PrizePos) = VIEWED Call PrintPrize(PrizePos) End If Next End If End Sub Sub ExitCmd_Click () End End Sub Sub Form_Activate () Dim PoleNo As Integer Dim StepNo As Integer Dim BarAdded As Integer If DoNew Then ReDim BarExists(NumLots, MaxBars) ' BarExists(NumLots, x) is not used but for avoiding Subscript Out Of Range ReDim BarPos(MaxBars + 1) ReDim PolePos(NumLots) ReDim LotStatus(NumLots) ReDim PrizeStatus(NumLots) ReDim IsPrize(NumLots) ReDim OwnerName$(NumLots) NumDrawnPrizes = 0 AlreadyDrawnOnce = False BarInterval = (BottomMost - TopMost) / (MaxBars + 1) PoleInterval = (Rightmost - LeftMost) / (NumLots - 1) If PoleInterval > 2000 Then PoleInterval = 2000 For i% = 0 To MaxLots - 1 Lot(i%).Visible = False Lot(i%).Top = 480 Lot(i%).Left = 0 Next For StepNo = 0 To MaxBars + 1 BarPos(StepNo) = TopMost + BarInterval * StepNo Next '****************************************************** ' Following code shuffles bars and prizez. '****************************************************** Randomize For PoleNo = 1 To NumLots LotStatus(PoleNo) = FREE PrizeStatus(PoleNo) = UNKNOWN OwnerName$(PoleNo) = "" PolePos(PoleNo) = LeftMost + PoleInterval * (PoleNo - 1) If PoleNo < NumLots Then BarAdded = False Do For StepNo = 5 To 34 If Rnd(1) - (MaxPersons - NumLots) * .02 > .9 Then If (PoleNo = 1 Or PoleNo >= 2 And BarExists(PoleNo - 1, StepNo) = False) And BarExists(PoleNo, StepNo - 1) = False Then BarExists(PoleNo, StepNo) = True BarAdded = True End If End If Next Loop Until BarAdded End If Next For i% = 1 To NumPrizes PoleNo = Int(Rnd(1) * NumLots) + 1 Do If PoleNo > NumLots Then PoleNo = 1 If IsPrize(PoleNo) = False Then IsPrize(PoleNo) = True Exit Do End If PoleNo = PoleNo + 1 Loop Next Refresh NumPrizesLbl.FontName = "Arial" NumPrizesLbl.Caption = "WINS:" + Format$(NumPrizes, " ##") DoNew = False End If Call Prompt End Sub Sub Form_Load () NumLots = 0 NumPrizes = 0 DoNew = 0 AppName$ = "Line Lottery" Caption = AppName$ PromptLbl.Caption = "" PuttingBar = False FontTransParent = False If Len(Command$) Then CharacterBaseFace = 1 Else CharacterBaseFace = 0 End If End Sub Sub Form_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single) Dim LotNo As Integer If NumDrawnPrizes = NumPrizes Then Exit Sub End If If Y <= TopMost And Y >= TopMost - Lot(0).Height - TextHeight(OwnerName$(Num)) - 40 Then 'Clicked a lot or a owner's face LotNo = (X - LeftMost) / PoleInterval + 1 If LotNo < 1 Then LotNo = 1 If LotNo > NumLots Then LotNo = NumLots Lot_Click (LotNo - 1) ElseIf PuttingBar Then If AddedBarPoleNo > 0 Then 'Add a bar for a person BarExists(AddedBarPoleNo, AddedBarStepNo) = True Line (PolePos(AddedBarPoleNo), BarPos(AddedBarStepNo))-(PolePos(AddedBarPoleNo + 1), BarPos(AddedBarStepNo)) PuttingBar = False Else Beep 'Clicked where a bar can't be added End If End If Call Prompt End Sub Sub Form_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single) Dim PoleNo As Integer Dim StepNo As Integer If PuttingBar = False Then Exit Sub PoleNo = Int((X - LeftMost) / PoleInterval) + 1 StepNo = Int((Y - TopMost) / BarInterval + .5) If PoleNo < 1 Or PoleNo >= NumLots Or StepNo < 1 Or StepNo > MaxBars Then If AddedBarPoleNo > 0 Then GoSub ErasePromptingBar End If AddedBarPoleNo = 0 Exit Sub End If If BarExists(PoleNo, StepNo) = False And (PoleNo = NumLots Or BarExists(PoleNo + 1, StepNo) = False) And (PoleNo = 1 Or BarExists(PoleNo - 1, StepNo) = False) Then If PoleNo <> AddedPoleNo Or StepNo <> AddedBarStepNo Then If AddedBarPoleNo > 0 Then GoSub ErasePromptingBar End If End If AddedBarPoleNo = PoleNo AddedBarStepNo = StepNo DrawStyle = 2 'Dot Line (PolePos(AddedBarPoleNo), BarPos(AddedBarStepNo))-(PolePos(AddedBarPoleNo + 1), BarPos(AddedBarStepNo)) DrawStyle = 0 'Solid Else GoSub ErasePromptingBar AddedBarPoleNo = 0 End If Exit Sub ErasePromptingBar: 'Erase the prompting bar which was previously drawn CurrentDrawMode = DrawMode DrawMode = 4 'Not Copy Pen Line (PolePos(AddedBarPoleNo), BarPos(AddedBarStepNo))-(PolePos(AddedBarPoleNo + 1), BarPos(AddedBarStepNo)) DrawMode = CurrentDrawMode PSet (PolePos(AddedBarPoleNo), BarPos(AddedBarStepNo)) PSet (PolePos(AddedBarPoleNo + 1), BarPos(AddedBarStepNo)) Return End Sub Sub Form_Paint () Dim LotNo As Integer Dim StepNo As Integer Cls DrawWidth = 1 For LotNo = 1 To NumLots Line (PolePos(LotNo), TopMost)-(PolePos(LotNo), BottomMost) If LotNo < NumLots Then For StepNo = 1 To MaxBars If BarExists(LotNo, StepNo) Then Line (PolePos(LotNo), BarPos(StepNo))-(PolePos(LotNo + 1), BarPos(StepNo)) End If Next End If Call PrintFace(LotNo, LotStatus(LotNo)) Call PrintPrize(LotNo) Next JustDrawn = False End Sub Sub Form_Unload (Cancel As Integer) Unload Help End Sub Sub HelpCmd_Click () Load Help Help.Caption = AppName + "- Help" Help.Show End Sub Sub Lot_Click (LotIndex As Integer) Dim LotNo As Integer LotNo = LotIndex + 1 If LotStatus(LotNo) = FREE Then 'Allocate a lot to a person PuttingBar = False PromptLbl.Caption = "" Call PrintFace(LotNo, BEINGSELECTED) frmName.Show 1 n$ = frmName.Tag Rem n$ = InputBox$("Name ?", AppName$, " ") If n$ > "" Then OwnerName$(LotNo) = n$ LotStatus(LotNo) = SELECTED Call PrintFace(LotNo, SELECTED) If AlreadyDrawnOnce = False Then PuttingBar = True End If Else Call PrintFace(LotNo, FREE) End If ElseIf LotStatus(LotNo) = SELECTED Then 'Draw a clicked lot PuttingBar = False Call DrawLot(LotNo) ElseIf PuttingBar Then Beep End If End Sub Sub NewCmd_Click () PuttingBar = False PromptLbl.Caption = "" QueryNum.Show Enabled = False End Sub Sub PrintFace (Num As Integer, State As Integer) Dim NetState As Integer If State = PRIZE Or State = BLANK Then If State = PRIZE And IsUnwillingPrize = 0 Or State = BLANK And IsUnwillingPrize Then NetState = PRIZE Else NetState = BLANK End If Else NetState = State End If If State = FREE Or State = BEINGSELECTED Or CharacterBaseFace Then Select Case NetState Case PRIZE If NumLots <= 7 Then Face$ = "!(^_^)!" ElseIf NumLots <= 10 Then Face$ = " (^_^) " ElseIf NumLots <= 12 Then Face$ = "(^_^)" Else Face$ = "^_^" End If Case BLANK If NumLots <= 10 Then Face$ = " (;_;) " ElseIf NumLots <= 12 Then Face$ = "(;_;)" Else Face$ = ";_;" End If Case SELECTED If NumLots <= 12 Then Face$ = "(-_-)" Else Face$ = "-_-" End If Case BEINGSELECTED Face$ = "O" Case Else Face$ = "@" End Select CurrentX = PolePos(Num) - TextWidth(Face$) / 2 CurrentY = TopMost - TextHeight(Face$) - 30 Print Face$ Else Lot(Num - 1).Top = TopMost - Lot(0).Height - 30 Lot(Num - 1).Left = PolePos(Num) - Lot(0).Width / 2 + 5 Select Case NetState Case PRIZE Lot(Num - 1).Picture = SmileFace.Picture Case BLANK Lot(Num - 1).Picture = SobFace.Picture Case SELECTED Lot(Num - 1).Picture = CalmFace.Picture End Select Lot(Num - 1).Visible = True End If CurrentX = PolePos(Num) - TextWidth(OwnerName$(Num)) / 2 CurrentY = TopMost - Lot(0).Height - TextHeight(OwnerName$(Num)) - 40 FontTransParent = True Print OwnerName$(Num) FontTransParent = False End Sub Sub PrintPrize (Num As Integer) If PrizeStatus(Num) = VIEWED Then If IsPrize(Num) Then X$ = "O" Else X$ = "X" End If Else X$ = "?" End If CurrentX = PolePos(Num) - TextWidth(X$) / 2 CurrentY = BottomMost + 20 Print X$ End Sub Sub Prompt () Dim LotNo As Integer If PuttingBar Then PromptLbl.Caption = "Click the left mouse button to add a horizonal line." ElseIf NumDrawnPrizes < NumPrizes Then For LotNo = 1 To NumLots If LotStatus(LotNo) = FREE Then PromptLbl.Caption = "To select, click the left mouse button on a @." Exit Sub End If Next PromptLbl.Caption = "" ElseIf NumLots > 0 Then PromptLbl.Caption = "All prizes have been selected" Else PromptLbl.Caption = "" End If End Sub Function TraceAmida (LotNo As Integer) Dim PoleNo As Integer Dim StepNo As Integer DrawWidth = 3 PoleNo = LotNo For StepNo = 1 To MaxBars + 1 Line (PolePos(PoleNo), BarPos(StepNo - 1))-(PolePos(PoleNo), BarPos(StepNo)) If StepNo <= MaxBars Then If PoleNo < NumLots Then If BarExists(PoleNo, StepNo) Then Line (PolePos(PoleNo), BarPos(StepNo))-(PolePos(PoleNo + 1), BarPos(StepNo)) PoleNo = PoleNo + 1 ' go to the right pole GoTo NextStep End If End If If PoleNo >= 2 Then If BarExists(PoleNo - 1, StepNo) Then Line (PolePos(PoleNo - 1), BarPos(StepNo))-(PolePos(PoleNo), BarPos(StepNo)) PoleNo = PoleNo - 1 ' go to the left pole End If End If End If NextStep: Next TraceAmida = PoleNo End Function 
(.txt)